perm filename CLEFS.F4[XX,LCS] blob sn#208644 filedate 1976-03-30 generic text, type T, neo UTF8
00100		SUBROUTINE CLEFS
00200		DIMENSION KPNT1(11),JCLEF(1050),RCMIN(4),KPNT2(11),KCLEF(350)
00300		1,CM(4),LCLEF(350),KPNT3(11)
00400		COMMON /STF/RSTFAC(8),RSTJ2 /PLTR/IPLT,RHT,DIS /BM/F,G,H
00500		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /MIN/MINI,RMINI
00600	      DATA RCMIN/3.3,10.5,7.0,10.5/,CM/.1,1.5,1.1,1.5/
00700		EQUIVALENCE (R4,RJQ(2)),(J5,JQ(3)),(J9,JQ(7)),(KK,
00800	     1 KPNT2(11)),(R6,RJQ(4)),(R5,RJQ(3)),(R8,RJQ(6)),(R7,RJQ(5))
00900		1,(DEG,R9,RJQ(7)),(NJR,RJQ(8)),(KJ,KPNT1(11)),(KCLEF,JCLEF(351))
01000		1,(R3,RJQ(1)),(LCLEF,JCLEF(701)),(KL,KPNT3(11))
01100		J5=MOD(J5,100)
01150		IF(J5)J5=-J5
01200		CALL NOZERO(R6)
01300		IF(R7.EQ.0)R7=R6
01400	C  IF P7 = 0, IT WILL EQUAL P6.
01500		IF(JA.GT.10)GO TO 9
01600		NAME='CLEF0'
01700		IF(J5.LT.20)GO TO 4
01800		R6=R6*.3
01900	C  SIZE FACTORS FOR SPECIAL WORDS, ETC. (PPP, MF, CRESC. ETC.)
02000		R7=R7*.3
02100		GO TO 4
02200	9	IF(NAME.EQ.NJR)GO TO 4
02300		IF(NAME.EQ.0)GO TO 177
02400		IF(NJR.EQ.0)GO TO 4
02500	177	IF(NJR.EQ.0)GO TO 8	
02600	C  TO PICK UP BASIC DRAW NAME FROM P10 
02700		NAME=NJR
02800		GO TO 4
02900	8	TYPE 5
03000	5	FORMAT(' SET P10=1'/)
03100	C  LEADS TO PROPER FILE CALL
03200	4	NM=NAME+2*(J5/10)
03300	C  DRAW0 HAS ITEMS 0→9;  DRAW1, 10→19; ETC. TO DRAW9, 90→99
03400		JEZ=MOD(J5,10)+1
03500	2	IF(NM.EQ.NM1)GO TO 30
03600		IF(NM.EQ.NM2)GO TO 30
03700		IF(NM.EQ.NM3)GO TO 30
03800	C  SET P10≠0 TO CHANGE BASIC 'DRAW' NAME.
03900	C  JUMP IF ALREADY IN CORE
04000		NPP=0
04100		IF(JA.NE.11)GO TO 1111
04200	C  DOESN'T CHECK LOOKUP ON CLEFS AND ALPHA'S.
04300		NPP=-1
04400		IF(LOOKF(NM))GO TO 1111
04500		TYPE 1112,NM
04600		RETURN
04700	1112	FORMAT(1XA5,' -- NOT FOUND')
04800	1111	CALL GETFI2(NM,NPP)
04900		IF(KX)33,133,233
05000	133	KX=-1
05100		NM1=NM
05200		CALL FASTI2(KPNT1,11)
05300		CALL FASTI2(JCLEF,KJ)
05400	C  NEW DATA READER  6/74 -- 5/75  HOLDS 3 .DMD FILES IF THEY FIT.
05500		IF(KJ.LE.350)GO TO 30
05600		KX=1
05700		NM2=0
05800		GO TO 30
05900	33	CALL FASTI2(KPNT2,11)
06000		KX=0
06100		IF(KK.GT.350)GO TO 1111
06200	C  JUMP BACK IF IT WON'T FIT.
06300		CALL FASTI2(KCLEF,KK)
06400		NM2=NM
06410		KX=1
06500		GO TO 30
06600	233	CALL FASTI2(KPNT3,11)
06700		KX=0
06800		IF(KL.GT.350)GO TO 1111
06900	C  JUMP BACK IF IT WON'T FIT.
07000		CALL FASTI2(LCLEF,KL)
07100		NM3=NM
07200	C   CHECK THE ABOVE  -- FOR P5 HEIGHT CHANGE *********************
07300	C  R6 IS SIZE FACTOR
07400	30	IF(J5.GT.3)GO TO 811
07500		IF(JA.NE.3)GO TO 811
07600	C  0=TREB, 1=BASS, 2=ALTO, 3=TENOR(ALTO SHIFTED UP)
07700	C  ↑↑↑↑↑↑↑↑  FIXUP SOMEDAY IN .DMD FILES
07800		IF(R5.LT.100)GO TO 812
07900		RSTJ2=.8*RSTJ2
08000	C  TO SET HGT. OF MINI CLEFS
08100		R4=R4+CM(JEZ)
08200	C  SHIFTS MINIS UP BECAUSE OF WRONG ORIG. POS.??
08300	812	IF(JEZ.NE.4)GO TO 811
08400		R4=R4+2
08500		JEZ=3
08600	C   ABOVE IS NOW AT TOP
08700	
08800	811	A=R4
08900		R4=A+2.9
08910	C  ADJUSTS HEIGHT(??)
09000		CALL CENTX
09100		R4=A
09200	
09300		L=KPNT1(JEZ)
09400		IF(NM.EQ.NM2)L=KPNT2(JEZ)+350
09500		IF(NM.EQ.NM3)L=KPNT3(JEZ)+700
09550		IF(L.LE.0)RETURN
09575	C CATCHES IMPOSSIBLE NUMBERS (I HOPE!)
09600		IF(J9.EQ.0)GO TO 31
09605	C***** ROTATE *******
09610		R7=R7*RSTJ2
09621		R6=R6*RSTJ2
09632		N=JCLEF(L)
09643		KNT=701
09654	C ROTATED DATA IS PUT STARTING AT LOCATION 701.(AREA FOR NM3)******
09665		JCLEF(KNT)=N
09676		DO 1 K=L+1,N+L-1
09687		CALL UNPACK(J,M,JCLEF(K))
09698		X=J*R6
09709		Y=M*R7
09720		JJ=JCLEF(K)/100000000
09731		AX=ATAN2(X,Y)*57.29578
09742		HYP=SQRT(X**2+Y**2)
09753		ROT=DEG+AX
09764		J=ROFF(HYP*COSD(ROT))
09775		M=ROFF(HYP*SIND(ROT))
09786		KNT=KNT+1
09797		IF(J)J=1000-J
09808		IF(M)M=1000-M
09819	1	JCLEF(KNT)=M*10000+J+JJ*100000000
09830		L=701
09841	C  ***********  SEE AT TOP **********
09852		R6=1.
09863		R7=1.
09874		RSTJ2=1.
09885	C  SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
09910	CC	CALL ROTATE(JCLEF,L)
09928		NM3=0
09946	C  WIPES OUT DATA AREA FOR NM3
09964	C  R9=P9=DEGREES OF ROTATION (0-360)
09982		IF(KK.GT.350)KX=0
10000	C CHECK TO SEE IF DATA WAS WIPED OUT.
10100	31	IF(R8.EQ.-2)GO TO 32
10200		IF(IPLT)GO TO 77
10300		IF(R8.NE.-1)GO TO 32
10400	C			R8=-2 OMITS FILLER DURING PLOT
10500	77	DO 3 K=L+1,JCLEF(L)+L
10600		IF(JCLEF(K).LT.200000000)GO TO 3
10700		JEZ=JCLEF(L)-1
10800		IF(K.GT.L+1)JEZ=JEZ-K+L+1
10900		CALL FILLMS(JEZ,JCLEF(K),R3,CENTR,R6,R7)
11000		GO TO 32
11100	3	CONTINUE
11200	C  FILLS ONLY WHEN PLOTING OR R8=-1
11300	32	CALL JDRAW(JCLEF(L),R3,CENTR,RSTJ2,R6,R7)
11400	C   3,POS.,STF,NT# OR CLEF,ITEM#,SIZEX,SIZEY, R8=-1 TO FILL ON CRT
11500	
11600		END